home *** CD-ROM | disk | FTP | other *** search
/ Shareware Overload Trio 2 / Shareware Overload Trio Volume 2 (Chestnut CD-ROM).ISO / dir44 / dungn32.zip / PARSER.FOR < prev    next >
Text File  |  1994-10-08  |  64KB  |  1,734 lines
  1. C Parser for DUNGEON
  2. C
  3. C COPYRIGHT 1980, 1990, INFOCOM COMPUTERS AND COMMUNICATIONS, CAMBRIDGE MA.
  4. C ALL RIGHTS RESERVED, COMMERCIAL USAGE STRICTLY PROHIBITED
  5. C WRITTEN BY R. M. SUPNIK
  6. C
  7. C 29-Sep-94     RMS     Fixed bugs in PLAY WITH, ALL BUT, GWIM, THISIT, IT.
  8. C                       Fixed vocabularly for ROCK, LIGHT, GATES, STACK,
  9. C                       BLIND.  Added COUNT, PERUSE, BLESSING, GHOSTS,
  10. C                       SPIRITS, CLIFFS, CORPSES, OUTPUT, CHIMNEY,
  11. C                       ZORKMID adjective, DIGBT flag.
  12. C 30-Jan-94     RMS     Fixed bug in error message.
  13. C 30-Jun-92     RMS     Changed file names to lower case.
  14. C 29-Jun-92     RMS     Removed extraneous declaration from SPARSE.
  15. C                       Added dummy argument to SYNMCH.
  16. C
  17. C RDLINE-       Read input line
  18. C
  19. C Declarations
  20. C
  21.       SUBROUTINE RDLINE(INLINE,INLEN,WHO)
  22.       IMPLICIT INTEGER(A-Z)
  23.       INCLUDE 'dparam.for'
  24.       CHARACTER*(TEXLNT) INLINE
  25. C
  26.       LUCVT=ICHAR('A')-ICHAR('a')               ! case conversion factor.
  27. 5     GO TO (90,10),WHO+1                       ! see who to prompt for.
  28. 10    WRITE(OUTCH,50)                           ! prompt for game.
  29. 50    FORMAT(' >',$)
  30. C
  31. 90    READ(INPCH,100,END=5) INLINE              ! get input.
  32. 100   FORMAT(A)
  33. C
  34.       INLEN=NBLEN(INLINE)                       ! len w/o trailing blanks.
  35.       IF(INLEN.LE.0) GO TO 5                    ! anything left?
  36.       DO 400 I=1,INLEN                          ! convert to upper case.
  37.         IF((INLINE(I:I).GE.'a').AND.(INLINE(I:I).LE.'z'))
  38.      1INLINE(I:I)=CHAR(ICHAR(INLINE(I:I))+LUCVT)
  39. 400   CONTINUE
  40.       PRSCON=1                                  ! restart lex scan.
  41.       RETURN
  42.       END
  43.  
  44. C PARSE-        Top level parse routine
  45. C
  46. C Declarations
  47. C
  48. C This routine details on bit 0 of PRSFLG
  49. C
  50.       LOGICAL FUNCTION PARSE(INLINE,INLEN,VBFLAG)
  51.       IMPLICIT INTEGER(A-Z)
  52.       INCLUDE 'dparam.for'
  53.       CHARACTER*(TEXLNT) INLINE
  54.       CHARACTER*(WRDLNT) OUTBUF(LEXMAX),BAKBUF(LEXMAX)
  55.       LOGICAL LEX,SYNMCH,DFLAG,VBFLAG
  56.       SAVE BAKBUF,BAKLEN
  57.       DATA BAKBUF(1)/'L'/,BAKLEN/1/
  58. C
  59.       DFLAG=(PRSFLG.AND.1).NE.0
  60.       PARSE=.FALSE.                             ! assume fails.
  61.       PRSA=0                                    ! zero outputs.
  62.       PRSI=0
  63.       PRSO=0
  64. C
  65.       IF(.NOT.LEX(INLINE,INLEN,OUTBUF,OUTLEN,VBFLAG)) GO TO 1000
  66.       IF((OUTLEN.NE.1).OR.(OUTBUF(1).NE.'AGAIN')) GO TO 100
  67.       DO 50 I=1,LEXMAX                          ! use previous
  68.         OUTBUF(I)=BAKBUF(I)
  69. 50    CONTINUE
  70.       OUTLEN=BAKLEN                             ! buffer and length.
  71. 100   IF(SPARSE(OUTBUF,OUTLEN,VBFLAG)) 1000,200,300 ! do syn scan.
  72. C
  73. C Parse requires validation
  74. C
  75. 200   IF(.NOT.VBFLAG) GO TO 350                 ! echo mode, force fail.
  76.       IF(.NOT.SYNMCH(X)) GO TO 1000             ! do syn match.
  77.       IF(PRSO.EQ.BUNOBJ) LASTIT=BUNVEC(1)       ! record for "it".
  78.       IF((PRSO.GT.0).AND.(PRSO.LT.BUNOBJ)) LASTIT=PRSO
  79. C
  80. C Successful parse or successful validation
  81. C
  82. 300   PARSE=.TRUE.
  83. 350   CALL ORPHAN(0,0,0,0,0,' ',0,0)            ! clear orphans.
  84.       DO 400 I=1,LEXMAX                         ! save command
  85.         BAKBUF(I)=OUTBUF(I)
  86. 400   CONTINUE
  87.       BAKLEN=OUTLEN                             ! save length
  88.       IF(DFLAG) WRITE(OUTCH,500) PARSE,PRSA,PRSO,PRSI
  89. 500   FORMAT(' PARSE RESULTS- ',L7,3I7)
  90.       RETURN
  91. C
  92. C Parse fails, disallow continuation
  93. C
  94. 1000  PRSCON=1
  95.       IF(DFLAG) WRITE(OUTCH,500) PARSE,PRSA,PRSO,PRSI
  96.       RETURN
  97. C
  98.       END
  99.  
  100. C LEX-  Lexical analyzer
  101. C
  102. C Declarations
  103. C
  104. C This routine details on bit 1 of PRSFLG
  105. C
  106.       LOGICAL FUNCTION LEX(INLINE,INLEN,OUTBUF,OP,VBFLAG)
  107.       IMPLICIT INTEGER(A-Z)
  108.       INCLUDE 'dparam.for'
  109.       CHARACTER*(TEXLNT) INLINE
  110.       CHARACTER*(WRDLNT) OUTBUF(LEXMAX)
  111.       CHARACTER*1 J
  112.       LOGICAL DFLAG,VBFLAG
  113. C
  114.       DFLAG=(PRSFLG.AND.2).NE.0
  115.       LEX=.FALSE.                               ! assume lex fails.
  116.       OP=0                                      ! output ptr.
  117.       DO 10 I=1,LEXMAX                          ! clear output buf.
  118.         OUTBUF(I)=' '
  119. 10    CONTINUE
  120. C
  121. 50    OP=OP+1                                   ! adv output ptr.
  122.       CP=0                                      ! char ptr=0.
  123. C
  124. 200   IF(PRSCON.GT.INLEN) GO TO 2000            ! end of input?
  125.       J=INLINE(PRSCON:PRSCON)                   ! no, get character,
  126.       IF((J.EQ.'"').OR.(J.EQ.'''')) GO TO 3000! substring?
  127.       PRSCON=PRSCON+1                           ! advance ptr.
  128.       IF(J.EQ.' ') GO TO 1000                   ! space?
  129.       IF((J.EQ.'.').OR.(J.EQ.';').OR.
  130.      1 (J.EQ.'!').or.(J.EQ.'?')) GO TO 2000     ! end of command?
  131.       IF(J.EQ.',') GO TO 4000                   ! comma?
  132.       IF(OP.GT.LEXMAX) GO TO 5000               ! too many tokens?
  133.       CP=CP+1                                   ! adv char ptr.
  134.       IF(CP.LE.WRDLNT) OUTBUF(OP)(CP:CP)=J      ! insert char in word.
  135.       GO TO 200
  136. C
  137. C Space.
  138. C
  139. 1000  IF(CP.EQ.0) GO TO 200                     ! any word yet?
  140.       GO TO 50                                  ! yes, adv op.
  141. C
  142. C End of input, see if partial word available.
  143. C
  144. 2000  IF(PRSCON.GT.INLEN) PRSCON=1              ! force parse restart.
  145.       IF((CP.EQ.0).AND.(OP.EQ.1)) RETURN        ! any results?
  146.       IF(CP.EQ.0) OP=OP-1                       ! any last word?
  147.       LEX=.TRUE.
  148.       IF(DFLAG) WRITE(OUTCH,2020) CP,OP,PRSCON,(OUTBUF(I),I=1,OP)
  149. 2020  FORMAT(' LEX RESULTS- ',3I7/1X,8(A,1X))
  150.       RETURN
  151. C
  152. C Substring, J is delimiter.
  153. C
  154. 3000  IF(SUBLNT.NE.0) GO TO 3400                ! already got one?
  155. 3100  PRSCON=PRSCON+1                           ! skip initial quote.
  156.       IF(PRSCON.GT.INLEN) GO TO 3500            ! any more characters?
  157.       IF(INLINE(PRSCON:PRSCON).EQ.' ') GO TO 3100 ! skip blanks.
  158.       K=INDEX(INLINE(PRSCON:INLEN),J)           ! find closing quote.
  159.       IF(K.LE.1) GO TO 3500                     ! none or empty?
  160.       SUBBUF=INLINE(PRSCON:PRSCON+K-2)          ! set up substring buffer,
  161.       SUBLNT=K-1                                ! length.
  162.       PRSCON=PRSCON+K                           ! skip over string.
  163.       IF(DFLAG) WRITE(OUTCH,3030) SUBLNT,SUBBUF(1:SUBLNT)
  164. 3030  FORMAT(' SUBSTRING- ',I7,' "',A,'"')
  165.       GO TO 1000                                ! treat as end of word.
  166. C
  167. 3400  IF(VBFLAG) CALL RSPEAK(1046)              ! multiple substrings.
  168.       RETURN
  169. C
  170. 3500  IF(VBFLAG) CALL RSPEAK(616)               ! bad substring.
  171.       RETURN                                    ! fails.
  172. C
  173. C Comma.
  174. C
  175. 4000  IF(CP.NE.0) OP=OP+1                       ! if partial word, go to next.
  176.       IF(OP.EQ.1) GO TO 4500                    ! no first word? die.
  177.       IF(OP.GT.LEXMAX) GO TO 5000               ! too many tokens?
  178.       OUTBUF(OP)='AND'                          ! insert 'AND'.
  179.       GO TO 50                                  ! start new word
  180. C
  181. 4500  IF(VBFLAG) CALL RSPEAK(1047)              ! misplaced comma.
  182.       RETURN
  183. C
  184. C Too many tokens.
  185. C
  186. 5000  IF(VBFLAG) CALL RSPEAK(1048)              ! too many tokens.
  187.       RETURN
  188. C
  189.       END
  190.  
  191. C SPARSE-       Start of parse
  192. C
  193. C Declarations
  194. C
  195. C This routine details on bit 2 of PRSFLG
  196. C
  197.       INTEGER FUNCTION SPARSE(LBUF,LLNT,VBFLAG)
  198.       IMPLICIT INTEGER(A-Z)
  199.       INCLUDE 'dparam.for'
  200.       CHARACTER*(WRDLNT) LBUF(LEXMAX),WORD,LCWORD,LCIFY
  201.       CHARACTER*(WRDLNT+2) LCWRD1
  202.       LOGICAL LIT,DFLAG,VBFLAG,ANDFLG,BUNFLG
  203.       INTEGER OBJVEC(2),PRPVEC(2)
  204.       EQUIVALENCE (OBJVEC(1),OBJ1),(PRPVEC(1),PREP1)
  205.  
  206. C SPARSE, PAGE 2
  207. C
  208. C Vocabularies
  209. C
  210. C Buzz words--  ignored in syntactic processing
  211. C
  212.       DATA BWORD/'BY','IS','A','AN','THE',
  213.      1'TODAY','MY','YOUR','OUR','HIS'/
  214. C
  215. C Prepositions--        maps prepositions to indices
  216. C
  217.       DATA PWORD/'OVER','WITH','USING','AT','TO',
  218.      1'IN','INSIDE','INTO','DOWN','UP',
  219.      2'UNDER','OF','ON','OFF','FOR',
  220.      3'FROM','OUT','THROUGH',' ',' '/
  221. C
  222.       DATA PVOC/1,2,2,3,4,
  223.      15,5,5,6,7,
  224.      28,9,10,11,12,
  225.      313,13,14,0,0/
  226. C
  227. C Directions--  maps directions to indices
  228. C
  229.       DATA DWORD/'N','NORTH','S','SOUTH',
  230.      1'E','EAST','W','WEST',
  231.      2'SE','SW','NE','NW',
  232.      4'U','UP','D','DOWN',
  233.      5'LAUNCH','LAND','EXIT','OUT',
  234.      6'TRAVEL','IN','CROSS',' ',' '/
  235. C
  236.       DATA DVOC/XNORTH,XNORTH,XSOUTH,XSOUTH,
  237.      1XEAST,XEAST,XWEST,XWEST,
  238.      2XSE,XSW,XNE,XNW,
  239.      4XUP,XUP,XDOWN,XDOWN,
  240.      5XLAUN,XLAND,XEXIT,XEXIT,
  241.      6XCROSS,XENTER,XCROSS,0,0/
  242.  
  243. C SPARSE, PAGE 3
  244. C
  245. C Adjectives--  maps adjectives to object numbers
  246. C
  247. C Each string entry in aword corresponds to a list of one or more
  248. C object numbers in AVOC.  Object entries are delimited by the first
  249. C object being positive, and all subsequent objects in the same entry
  250. C being negative.
  251. C
  252.       DATA (AWORD(I),I=1,40) /
  253.      1'BROWN','ELONGATE','HOT','PEPPER',
  254.      1'VITREOUS','JADE','HUGE','ENORMOUS',
  255.      2'TROPHY','CLEAR','LARGE','NASTY',
  256.      3'ELVISH','BRASS','BROKEN','ORIENTAL',
  257.      4'BLOODY','RUSTY','BURNED-O','DEAD',
  258.      5'OLD','LEATHER','PLATINUM','PEARL',
  259.      6'MOBY','CRYSTAL','GOLD','IVORY',
  260.      7'SAPPHIRE','WOODEN','WOOD','STEEL',
  261.      8'DENTED','FANCY','ANCIENT','SMALL',
  262.      9'BLACK','TOUR','VISCOUS','VICIOUS'/
  263. C
  264.       DATA (AVOC(I),I=1,112) /
  265.      11,-81,-133,1,3,-190,3,
  266.      14,6,8,8,-122,
  267.      29,10,12,-26,-47,-95,-96,-123,-133,-135,-144,-145,
  268.      2-150,-176,-191,13,-19,
  269.      314,15,-16,-46,-156,-190,16,-22,-38,-92,-113,-155,-158,17,
  270.      420,24,-205,22,22,
  271.      525,-41,-44,-45,-208,25,26,27,
  272.      631,32,-126,-206,-209,33,-85,-104,-157,-158,-188,34,
  273.      737,38,-67,-75,-93,-136,-137,-165,-173,-174,-175,-197,-204,
  274.      738,-67,-136,-137,-165,-173,-174,-175,
  275.      739,-105,-124,-125,-189,
  276.      839,40,41,-44,5,-46,-52,-53,-89,-102,-103,-153,-187,
  277.      947,-162,49,55,62/
  278. C
  279.       DATA (AWORD(I),I=41,80) /
  280.      1'GLASS','TRAP','FRONT','STONE',
  281.      1'MANGLED','RED','YELLOW','BLUE',
  282.      2'VAMPIRE','MAGIC','SEAWORTH','TAN',
  283.      3'SHARP','WICKER','CLOTH','BRAIDED',
  284.      4'GAUDY','SQUARE','CLAY','SHINY',
  285.      5'THIN','GREEN','PURPLE','WHITE',
  286.      6'MARBLE','COKE','EMPTY','ROUND',
  287.      7'TRIANGUL','RARE','OBLONG','EAT-ME',
  288.      8'EATME','ORANGE','ECCH','ROCKY',
  289.      9'SHEER','200','NEAT','SHIMMERI'/
  290. C
  291.       DATA (AVOC(I),I=113,179) /
  292.      110,-126,-132,-206,-209,66,68,69,-150,-278,
  293.      1          72,-124,79,-94,-140,-161,-170,-171,-190,-209,
  294.      180,-159,82,-112,-114,-141,-206,
  295.      283,90,-281,90,91,
  296.      392,98,100,101,
  297.      4108,109,-127,109,110,
  298.      5110,77,-115,-143,116,117,-126,-147,-160,-266,
  299.      6119,121,121,128,
  300.      7129,134,135,138,
  301.      8138,139,141,146,
  302.      9146,148,148,151/
  303. C
  304.       DATA (AWORD(I),I=81,120) /
  305.      1'ZURICH','BIRDS','ENCRUSTE','BEAUTIFU',
  306.      1'CLOCKWOR','MECHANIC','MAHOGANY','PINE',
  307.      2'LONG','CENTER','SHORT','T',
  308.      3'COMPASS','BRONZE','CELL','LOCKED',
  309.      4'SUN','BARE','SONG','NORTH',
  310.      5'NORTHERN','SOUTH','SOUTHERN','EAST',
  311.      6'EASTERN','WEST','WESTERN','DUNGEON',
  312.      7'FREE','GRANITE','LOWERED','VOLCANO',
  313.      8'MAN-SIZE','METAL','PLASTIC','SILVER',
  314.      9'USED','USELESS','SEEING','ONE-EYED'/
  315. C
  316.       DATA (AVOC(I),I=180,238) /
  317.      1152,153,-154,-155,154,-155,86,-156,
  318.      1157,-158,157,-158,163,164,
  319.      2166,166,167,168,
  320.      3169,-275,172,174,-175,174,
  321.      4177,259,267,269,
  322.      5269,270,270,271,
  323.      6271,67,-272,67,-272,279,
  324.      7195,-262,265,36,111,
  325.      893,64,-99,-200,-201,77,-87,-88,-90,59,
  326.      922,22,126,-206,-209,58/
  327. C
  328.       DATA (AWORD(I),I=121,160) /
  329.      1'HOLY','HAND-HEL','UNRUSTY','PLAIN',
  330.      1'PRICELES','SANDY','GIGANTIC','LINE-PRI',
  331.      2'FLATHEAD','FINE','SHADY','SUSPICIO',
  332.      3'CROSS','TOOL','CONTROL','DON',
  333.      4'WOODS','GOLDEN','OAK','BARRED',
  334.      5'DUSTY','NARROW','IRON','WELCOME',
  335.      6'RUBBER','SKELETON','ALL','ZORKMID',
  336.      712*' '/
  337. C
  338.       DATA (AVOC(I),I=239,282) /
  339.      143,89,13,13,
  340.      1104,192,122,122,
  341.      2118,91,61,61,
  342.      3165,193,194,196,
  343.      4196,157,-158,197,198,-210,
  344.      5204,199,205,207,
  345.      6207,23,253,-254,104,-148,
  346.      712*0/
  347.  
  348. C SPARSE, PAGE 4
  349. C
  350. C OBJECTS--     Maps objects to object indices,
  351. C               same format as AVOC.
  352. C
  353.       DATA (OWORD(I),I=1,40) /
  354.      1'BAG','SACK','GARLIC','CLOVE',
  355.      1'FOOD','SANDWICH','LUNCH','DINNER',
  356.      2'GUNK','PIECE','SLAG','COAL',
  357.      3'PILE','HEAP','FIGURINE','MACHINE',
  358.      4'PDP10','VAX','DRYER','LID',
  359.      5'DIAMOND','CASE','BOTTLE','CONTAINE',
  360.      6'WATER','QUANTITY','LIQUID','H2O',
  361.      7'ROPE','HEMP','COIL','KNIFE',
  362.      8'BLADE','SWORD','ORCHRIST','GLAMDRIN',
  363.      9'LAMP','LANTERN','RUG','CARPET'/
  364. C
  365.       DATA (OVOC(I),I=1,71) /
  366.      11,-25,-100,1,2,2,
  367.      13,3,3,3,
  368.      24,-55,4,-143,-186,-282,4,5,
  369.      35,-18,-38,-72,-73,-87,-88,-122,-148,5,6,7,
  370.      47,7,7,7,-200,-201,
  371.      58,9,-123,10,-121,10,
  372.      611,-273,11,-273,11,-273,11,-273,
  373.      712,-101,-282,12,12,-110,13,-24,
  374.      813,-14,14,14,14,
  375.      915,-16,-22,15,-16,-22,17,17/
  376. C
  377.       DATA (OWORD(I),I=41,80) /
  378.      1'LEAVES','LEAF','TROLL','AXE',
  379.      1'PRAYER','KEYS','KEY','SET',
  380.      2'BONES','SKELETON','BODY','COINS',
  381.      3'BAR','NECKLACE','PEARLS','MIRROR',
  382.      4'ICE','MASS','GLACIER','RUBY',
  383.      5'TRIDENT','FORK','COFFIN','CASKET',
  384.      6'TORCH','CAGE','DUMBWAIT','BASKET',
  385.      7'BRACELET','JEWEL','TIMBER','BOX',
  386.      8'STRADIVA','VIOLIN','ENGRAVIN','INSCRIPT',
  387.      9'GHOST','SPIRIT','FIEND','GRAIL'/
  388. C
  389.       DATA (OVOC(I),I=72,130) /
  390.      118,18,19,-111,20,
  391.      144,-47,23,23,-205,23,
  392.      221,21,21,-72,-73,25,
  393.      326,-165,-168,27,27,28,-29,-276,
  394.      430,30,30,31,
  395.      532,32,33,33,
  396.      634,35,-36,-124,-125,35,-36,35,-36,-98,-113,
  397.      737,37,38,39,-53,-105,
  398.      840,40,41,41,-44,
  399.      942,42,42,43/
  400. C
  401.       DATA (OWORD(I),I=81,120) /
  402.      1'TRUNK','CHEST','BELL','BOOK',
  403.      1'BIBLE','GOODBOOK','CANDLES','PAIR',
  404.      2'GUIDEBOO','GUIDE','PAPER','NEWSPAPE',
  405.      3'ISSUE','REPORT','MAGAZINE','NEWS',
  406.      4'MATCHBOO','MATCH','MATCHES','ADVERTIS',
  407.      5'PAMPHLET','LEAFLET','BOOKLET','MAILBOX',
  408.      6'TUBE','TOOTHPAS','PUTTY','MATERIAL',
  409.      7'GLUE','WRENCH','SCREWDRI','CYCLOPS',
  410.      8'MONSTER','CHALICE','CUP','GOBLET',
  411.      9'PAINTING','ART','CANVAS','PICTURE'/
  412. C
  413.       DATA (OVOC(I),I=131,182) /
  414.      145,45,-193,46,-190,47,-49,-114,-115,-116,-117,
  415.      147,47,48,48,
  416.      249,49,50,-122,-143,-186,50,
  417.      350,50,50,50,
  418.      451,51,51,52,
  419.      552,52,52,53,
  420.      654,54,55,55,
  421.      755,56,57,58,
  422.      858,59,59,59,
  423.      960,-149,60,-149,60,60/
  424. C
  425.       DATA (OWORD(I),I=121,160) /
  426.      1'WORK','MASTERPI','THIEF','ROBBER',
  427.      1'CRIMINAL','BANDIT','CROOK','GENT',
  428.      2'GENTLEMA','MAN','INDIVIDU','BAGMAN',
  429.      3'STILETTO','WINDOW','BOLT','NUT',
  430.      4'GRATE','GRATING','DOOR','TRAP-DOO',
  431.      5'SWITCH','HEAD','CORPSE','BODIES',
  432.      6'DAM','GATES','GATE','FCD',
  433.      7'RAIL','RAILING','BUTTON','BUBBLE',
  434.      8'LEAK','DRIP','HOLE','BAT',
  435.      9'RAINBOW','POT','STATUE','SCULPTUR'/
  436. C
  437.       DATA (OVOC(I),I=183,258) /
  438.      160,60,61,61,
  439.      161,61,61,61,
  440.      261,61,61,61,
  441.      362,63,-198,-210,64,64,
  442.      465,65,66,-67,-68,-69,-119,-164,
  443.      4-172,-173,-174,-175,-189,-197,66,
  444.      570,-79,-80,-81,-82,-170,71,-120,72,-73,72,-73,
  445.      674,74,-76,74,-76,74,
  446.      775,75,76,-79,-80,-81,-82,-127,-128,-129,-170,-176,77,
  447.      878,-191,78,78,-107,-202,-203,83,
  448.      984,85,86,86/
  449. C
  450.       DATA (OWORD(I),I=161,200) /
  451.      1'ROCK','BOAT','PLASTIC','PUMP',
  452.      1'AIRPUMP','AIR-PUMP','LABEL','FINEPRIN',
  453.      2'STICK','BARREL','BUOY','EMERALD',
  454.      3'SHOVEL','GUANO','CRAP','SHIT',
  455.      4'HUNK','BALLOON','RECEPTAC','WIRE',
  456.      5'HOOK','ZORKMID','COIN','SAFE',
  457.      6'CARD','NOTE','SLOT','CROWN',
  458.      7'BRICK','FUSE','GNOME','STAMP',
  459.      8'TOMB','CRYPT','GRAVE','HEADS',
  460.      9'POLES','IMPLEMEN','LOSERS','COKES'/
  461. C
  462.       DATA (OVOC(I),I=259,312) /
  463.      186,87,-88,-90,87,-88,-90,89,
  464.      189,89,91,-112,91,
  465.      292,93,94,95,
  466.      396,97,97,97,
  467.      497,98,-113,99,101,-110,
  468.      5102,-103,104,-148,104,105,
  469.      6106,-188,106,-186,107,-187,108,
  470.      7109,110,111,-152,118,-196,
  471.      8119,119,119,120,
  472.      9120,120,120,121/
  473. C
  474.       DATA (OWORD(I),I=201,240) /
  475.      1'LISTINGS','OUTPUT','PRINTOUT','SPHERE',
  476.      1'BALL','ETCHING','WALLS','WALL',
  477.      2'FLASK','POOL','SEWAGE','TIN',
  478.      3'SAFFRON','SPICES','TABLE','POST',
  479.      4'POSTS','BUCKET','CAKE','ICING',
  480.      5'ROBOT','ROBBY','C3PO','R2D2',
  481.      6'PANEL','POLE','TBAR','T-BAR',
  482.      7'ARROW','POINT','BEAM','DIAL',
  483.      8'SUNDIAL','1','ONE','2',
  484.      9'TWO','3','THREE','4'/
  485. C
  486.       DATA (OVOC(I),I=313,387) /
  487.      1122,122,122,126,-206,-209,
  488.      1126,130,-131,130,-131,-257,130,-131,-159,
  489.      1-160,-161,-162,-163,-164,-257,-265,-269,-270,-271,-272,
  490.      2132,133,133,134,
  491.      3134,134,135,-204,136,-166,-167,
  492.      4136,137,138,-139,-140,-141,139,-140,-141,
  493.      5142,142,142,142,
  494.      6159,-160,-161,-162,-163,-164,-194,-277,120,-166,-167,168,168,
  495.      7169,169,171,177,
  496.      8177,178,178,179,
  497.      9179,180,180,181/
  498. C
  499.       DATA (OWORD(I),I=241,280) /
  500.      1'FOUR','5','FIVE','6',
  501.      1'SIX','7','SEVEN','8',
  502.      2'EIGHT','WARNING','SLIT','IT',
  503.      3'THAT','THIS','ME','MYSELF',
  504.      4'CRETIN','ALL','EVERYTHI','TREASURE',
  505.      5'VALUABLE','SAILOR','TEETH','GRUE',
  506.      6'HAND','HANDS','LUNGS','AIR',
  507.      7'AVIATOR','FLYER','TREE','CLIFF',
  508.      8'LEDGE','PORTRAIT','STACK','BILLS',
  509.      9'VAULT','CUBE','LETTERIN','CURTAIN'/
  510. C
  511.       DATA (OVOC(I),I=388,432) /
  512.      1181,182,182,183,
  513.      1183,184,184,185,
  514.      2185,186,187,250,
  515.      3250,250,251,251,
  516.      4251,252,252,253,
  517.      5253,255,256,258,
  518.      6259,259,260,260,
  519.      7261,261,144,-145,-268,146,-147,
  520.      8146,149,122,-148,148,
  521.      9150,150,67,-150,151/
  522. C
  523.       DATA (OWORD(I),I=281,320) /
  524.      1'LIGHT','NEST','EGG','BAUBLE',
  525.      1'CANARY','BIRD','SONGBIRD','GUARD',
  526.      2'GUARDIAN','ROSE','STRUCTUR','CHANNEL',
  527.      3'KEEPER','LADDER','BROCHURE','WISH',
  528.      4'GROUND','EARTH','SAND','WELL',
  529.      5'SLIDE','CHUTE','HOUSE','BOTTLES',
  530.      6'BUNCH','PALANTIR','STONE','FLINT',
  531.      7'POSSESSI','GOOP','BEACH','GRIP',
  532.      8'HANDGRIP','PRINT','ETCHINGS','CRACK',
  533.      9'KEYHOLE','MAT','STOVE','PLATINUM'/
  534. C
  535.       DATA (OVOC(I),I=433,485) /
  536.      115,-151,-171,153,154,-155,156,
  537.      1157,-158,267,267,274,
  538.      2274,275,276,278,
  539.      3279,280,195,-262,263,
  540.      4264,264,192,-264,281,
  541.      5283,283,266,121,
  542.      6121,126,-206,-209,126,-206,-209,51,
  543.      7254,133,192,167,
  544.      8167,91,-122,130,-131,199,
  545.      9202,-203,207,208,26/
  546. C
  547.       DATA (OWORD(I),I=321,360) /
  548.      1'HIM','SELF','GOLD','SAPPHIRE',
  549.      1'IVORY','MASTER','CANDLE','JADE',
  550.      2'SCREEN','BLESSING','GHOSTS','SPIRITS',
  551.      3'CORPSES','JEWELS','CLIFFS','CHIMNEY',
  552.      424*' '/
  553. C
  554.       DATA (OVOC(I),I=486,529) /
  555.      1250,251,85,-104,37,
  556.      134,279,48,6,
  557.      2151,263,42,42,
  558.      372,-73,37,-45,146,-147,211,
  559.      424*0/
  560.  
  561. C SPARSE, PAGE 5
  562. C
  563. C VERBS--       Maps verbs to syntax slots
  564. C
  565. C Vocabulary entries are variable length and consist of one
  566. C or more words.  If an entry contains more than one word,
  567. C all but the last are prefaced with an '*'.  The preferred
  568. C string for error messages should be first.
  569. C
  570. C Syntax entries consist of a flag word followed by 0, 1, or 2
  571. C Object descriptions.  The flag word has the following format--
  572. C
  573. C bit <14>      if 1, syntax includes direct object
  574. C bit <13>      if 1, syntax includes indirect object
  575. C bit <12>      if 1, direct object is implicit (standard form)
  576. C bit <11>      if 1, direct and indirect object must be swapped
  577. C                       after syntax processing
  578. C bit <10>      if 1, this is default syntax for orphanery
  579. C bits <8:0>    verb number for VAPPLI
  580. C
  581. C Object descriptions consist of a flag word and two FWIM words.
  582. C The flag word has the following format--
  583. C
  584. C bit <14>      if 1, search adventurer for object
  585. C bit <13>      if 1, search room for object
  586. C bit <12>      if 1, parser will try to take object
  587. C bit <11>      if 1, adventurer must have object
  588. C bit <10>      if 1, qualifying bits (normally -1,-1) are same
  589. C                       as FWIM bits
  590. C bit <9>       if 1, object must be reachable
  591. C bits <8:0>    preposition number for SYNMCH
  592. C
  593. C The FWIM words have the same format as the two object flag words.
  594. C
  595. C Note that bits 12 and 11 of object descriptions actually have
  596. C four distinct states--
  597. C
  598. C       bit 12  bit 11  mdldesc         interpretation
  599. C       ------  ------  -------         ---------------
  600. C
  601. C         0       0      --             no parser action
  602. C         0       1      HAVE           adventurer must have object
  603. C         1       0      TRY            try to take, dont care if fail
  604. C         1       1      TAKE           try to take, care if fail
  605. C
  606.  
  607. C SPARSE, PAGE 6
  608. C
  609.       DATA (VWORD(I),I=1,43) /
  610.      1'BRIEF','VERBOSE','SUPERBRI','STAY',
  611.      1'VERSION','*SWIM','*BATHE','WADE',
  612.      2'GERONIMO','*ULYSSES','ODYSSEUS','*PLUGH','XYZZY',
  613.      3'PRAY','TREASURE','TEMPLE','BLAST',
  614.      4'SCORE','*QUIT','*GOODBYE','*Q','BYE','HELP',
  615.      5'INFO','*HISTORY','UPDATE','BACK',
  616.      6'*MUMBLE','SIGH','*CHOMP','*LOSE',
  617.      7'BARF','DUNGEON','FROBOZZ','*FOO',
  618.      8'*BLETCH','BAR','REPENT','*HOURS',
  619.      9'SCHEDULE','WIN','*YELL','*SCREAM'/
  620. C
  621.       DATA (VVOC(I),I=1,54) /
  622.      11,70,1,71,1,72,1,73,
  623.      11,74,1,75,
  624.      21,76,1,77,1,56,
  625.      31,79,1,80,1,81,1,82,
  626.      41,83,1,84,1,40,
  627.      51,41,1,42,1,43,
  628.      61,44,
  629.      71,45,1,46,1,47,
  630.      81,48,1,49,
  631.      91,50,1,51/
  632. C
  633.       DATA (VWORD(I),I=44,86) /
  634.      1'SHOUT','*HOP','SKIP','*CURSE',
  635.      1'*SHIT','*DAMN','FUCK','ZORK',
  636.      2'WISH','SAVE','RESTORE','TIME',
  637.      3'DIAGNOSE','EXORCISE','*LIST','*I','INVENTOR',
  638.      4'WAIT','INCANT','*ANSWER','RESPOND','AGAIN',
  639.      5'NOOBJ','*BUG','*GRIPE','COMPLAIN',
  640.      6'*FEATURE','*COMMENT','*IDEA','SUGGESTI',
  641.      7'ROOM','*OBJECTS','OBJ','RNAME','DEFLATE',
  642.      8'*EXAMINE','*WHAT','DESCRIBE','FILL',
  643.      9'*FIND','*SEEK','*WHERE','SEE'/
  644. C
  645.       DATA (VVOC(I),I=55,120) /
  646.      11,52,1,53,
  647.      11,54,1,55,
  648.      21,169,1,149,1,150,1,90,
  649.      31,94,1,105,1,133,
  650.      41,128,1,95,1,96,1,57,
  651.      51,58,1,59,
  652.      61,60,
  653.      71,65,1,66,1,67,1,8#50147,
  654.      84,8#40170,8#60000,-1,-1,
  655.      811,8#60206,8#61000,8#200,0,8#61002,-1,-1,
  656.      88#40206,8#61000,8#200,0,
  657.      94,8#40177,8#60000,-1,-1/
  658. C
  659.       DATA (VWORD(I),I=87,131) /
  660.      1'FOLLOW','*KICK','*BITE','TAUNT',
  661.      1'LOWER','*PUSH','PRESS','*RING',
  662.      2'PEAL','*RUB','*FEEL','*CARESS','*TOUCH',
  663.      3'FONDLE','SHAKE','SPIN','*UNTIE',
  664.      4'FREE','*WALK','*RUN','*PROCEED','GO','*ATTACK','*FIGHT',
  665.      5'*INJURE','*HIT','HURT','BOARD',
  666.      6'*BRUSH','CLEAN','*BURN','*IGNITE',
  667.      7'INCINERA','CLIMB','CLOSE','DIG',
  668.      8'DISEMBAR','*DRINK','*IMBIBE','SWALLOW',
  669.      9'*DROP','RELEASE','*EAT','*GOBBLE','*CONSUME'/
  670. C
  671.       DATA (VVOC(I),I=121,278) /
  672.      12,8#125,8#50125,1,8#50153,
  673.      11,8#50156,9,8#50160,8#40160,8#61012,-1,-1,
  674.      18#40241,8#61010,-1,-1,
  675.      25,8#52127,8#70127,8#61002,-1,-1,
  676.      31,8#50157,1,8#50171,1,8#50201,
  677.      411,8#42161,8#61000,0,8#10000,
  678.      48#60242,8#61000,0,8#10000,8#61015,-1,-1,
  679.      49,8#50216,8#40126,8#61016,-1,-1,8#40126,8#61005,-1,-1,
  680.      57,8#60215,8#21000,0,8#200,8#44002,0,8#1000,
  681.      54,8#40202,8#21000,0,2,
  682.      65,8#52130,8#70130,8#61002,-1,-1,
  683.      77,8#60211,8#61000,8#20,0,8#64002,8#10,0,
  684.      712,8#40235,8#20007,0,8#4000,8#40236,8#20006,0,8#4000,
  685.      78#40234,8#20000,0,8#4000,
  686.      74,8#40176,8#61000,8#10200,0,
  687.      721,8#60131,8#20005,0,8#40000,8#44002,4,0,
  688.      7          8#60131,8#20016,0,8#40000,8#44002,4,0,
  689.      7          8#60131,8#20000,0,8#40000,8#44002,4,0,
  690.      88,8#40203,8#20000,0,2,8#40203,8#20015,0,2,
  691.      84,8#40210,8#61000,8#400,0,
  692.      925,8#42221,8#41000,-1,-1,
  693.      98#60220,8#41000,-1,-1,8#61005,-1,-1,
  694.      98#60220,8#41000,-1,-1,8#61006,-1,-1,
  695.      98#60220,8#41000,-1,-1,8#61016,-1,-1/
  696. C
  697.       DATA (VWORD(I),I=132,172) /
  698.      1'*MUNCH','TASTE','*DOUSE','EXTINGUI',
  699.      1'*GIVE','*HAND','DONATE','*HELLO',
  700.      2'HI','BLOW','INFLATE','*JUMP',
  701.      3'LEAP','*KILL','*MURDER','*SLAY',
  702.      4'*STAB','DISPATCH','*KNOCK','RAP',
  703.      5'LIGHT','LOCK','*LOOK','*L','*STARE',
  704.      6'GAZE','*MELT','LIQUIFY','MOVE',
  705.      7'*PULL','TUG','*DESTROY','*MUNG',
  706.      8'*BREAK','DAMAGE','OPEN','PICK',
  707.      9'*PLUG','*GLUE','PATCH','*POKE'/
  708. C
  709.       DATA (VVOC(I),I=279,450) /
  710.      14,8#40207,8#75000,8#2000,0,
  711.      14,8#40174,8#75000,8#100,0,
  712.      111,8#72222,8#21004,8#40,0,8#64222,8#21000,8#40,0,
  713.      18#61000,-1,-1,
  714.      22,8#2227,8#50227,
  715.      215,8#62146,8#61007,-1,-1,8#61002,4,0,
  716.      28#40122,8#61007,-1,-1,8#40165,8#61005,-1,-1,
  717.      24,8#70146,8#61002,4,0,
  718.      35,8#133,8#40133,8#61001,-1,-1,
  719.      47,8#60213,8#21000,0,8#200,8#44002,0,8#1000,
  720.      412,8#42166,8#61003,-1,-1,8#40166,8#61012,-1,-1,
  721.      48#40215,8#23006,8#40,0,
  722.      511,8#42173,8#75000,8#100,0,8#60211,8#61000,8#100,0,
  723.      58#54002,8#10,0,
  724.      57,8#60134,8#20000,-1,-1,8#74002,4,0,
  725.      631,8#167,8#40170,8#60003,-1,-1,8#40231,8#61010,-1,-1,
  726.      68#40230,8#60005,-1,-1,8#40230,8#60016,-1,-1,
  727.      68#60144,8#60003,-1,-1,8#61002,-1,-1,
  728.      68#60144,8#60003,-1,-1,8#61016,-1,-1,
  729.      64,8#70145,8#61002,8#10,0,
  730.      64,8#40172,8#20000,-1,-1,
  731.      78,8#42172,8#21000,-1,-1,8#40172,8#21012,-1,-1,
  732.      85,8#52212,8#70212,8#44002,-1,-1,
  733.      811,8#42175,8#61000,8#10200,0,8#60175,8#61000,8#10200,0,
  734.      88#54002,4,8#1000,
  735.      84,8#40204,8#61007,8#20000,8#40,
  736.      94,8#70152,8#61002,-1,-1/
  737. C
  738.       DATA (VWORD(I),I=173,212) /
  739.      1'*BLIND','JAB','*POUR','SPILL',
  740.      1'PUMP','*PUT','*INSERT','*STUFF',
  741.      2'PLACE','*RAISE','LIFT','*READ',
  742.      3'*PERUSE','SKIM','STRIKE','*SWING',
  743.      4'THRUST','*TAKE','*HOLD','*CARRY',
  744.      5'REMOVE','*TELL','*COMMAND','REQUEST',
  745.      6'*THROW','*HURL','CHUCK','*TIE',
  746.      7'FASTEN','*TURN','SET','UNLOCK',
  747.      8'*WAKE','*ALARM','*STARTLE','SURPRISE',
  748.      9'*WAVE','*FLAUNT','BRANDISH','WIND'/
  749. C
  750.       DATA (VVOC(I),I=451,654) /
  751.      17,8#60212,8#21000,0,8#200,8#44002,0,8#1000,
  752.      125,8#42223,8#41000,8#400,0,
  753.      18#60223,8#41000,8#400,0,8#61005,-1,-1,
  754.      18#60223,8#41000,8#400,0,8#61016,-1,-1,
  755.      18#60240,8#41000,8#400,0,8#61012,-1,-1,
  756.      14,8#60232,8#60007,-1,-1,
  757.      216,8#72220,8#61005,-1,-1,8#70220,8#61016,-1,-1,
  758.      28#40221,8#61006,-1,-1,8#70241,8#61010,-1,-1,
  759.      25,8#52155,8#40155,8#61007,-1,-1,
  760.      318,8#42144,8#71000,8#40000,0,
  761.      38#60144,8#71000,8#40000,0,8#61002,-1,-1,
  762.      38#60144,8#71000,8#40000,0,8#61016,-1,-1,
  763.      312,8#60215,8#23000,8#40,0,8#44002,0,8#1000,
  764.      38#42215,8#23000,8#40,0,8#50173,
  765.      47,8#60214,8#44000,0,8#1000,8#21003,0,8#200,
  766.      511,8#42204,8#61000,8#20000,8#40,
  767.      58#60204,8#61000,8#20000,0,8#61015,-1,-1,
  768.      54,8#40217,8#20000,0,8#2000,
  769.      621,8#62224,8#44000,-1,-1,8#21003,8#40,0,
  770.      68#60224,8#44000,-1,-1,8#21016,8#40,0,
  771.      68#60220,8#44000,-1,-1,8#61005,-1,-1,
  772.      711,8#70162,8#61004,-1,-1,8#60163,8#21007,8#40,0,
  773.      78#65002,4,0,
  774.      722,8#62164,8#61000,2,0,8#64002,4,0,
  775.      78#40173,8#75012,8#100,0,8#40174,8#75013,8#100,0,
  776.      78#60237,8#61000,2,0,8#20004,-1,-1,
  777.      77,8#60135,8#21000,-1,-1,8#74002,4,0,
  778.      88,8#42150,8#20000,8#40,0,8#40150,8#20007,8#40,0,
  779.      94,8#40154,8#40000,-1,-1,
  780.      95,8#50233,8#40233,8#61007,-1,-1/
  781. C
  782.       DATA (VWORD(I),I=213,240)/
  783.      1'ENTER','LEAVE','*MAKE','BUILD',
  784.      1'*OIL','*GREASE','LUBRICAT','PLAY',
  785.      2'SEND','SLIDE','*SMELL','SNIFF',
  786.      3'SQUEEZE','GET','COUNT',13*' '/
  787. C
  788.       DATA (VVOC(I),I=655,722) /
  789.      12,167,8#50126,2,168,8#50220,1,8#50243,
  790.      14,8#70244,8#41002,-1,-1,
  791.      15,8#50245,8#70245,8#75002,4,0,
  792.      24,8#40246,8#61014,-1,-1,
  793.      24,8#70241,8#61010,-1,-1,1,8#50105,
  794.      31,8#50104,19,8#42204,8#61000,8#20000,8#40,
  795.      38#40202,8#21005,0,2,8#40203,8#21015,0,2,
  796.      38#60204,8#61000,8#20000,8#40,8#61015,-1,-1,
  797.      31,8#50141,13*0/
  798.  
  799. C SPARSE, PAGE 7
  800. C
  801. C Set up for parsing
  802. C
  803.       SPARSE=-1                                 ! assume parse fails.
  804.       ADJ=0                                     ! clear parts holders.
  805.       ACT=0
  806.       PREP=0
  807.       PPTR=0
  808.       OBJ1=0
  809.       OBJ2=0
  810.       PREP1=0
  811.       PREP2=0
  812.       LOBJ=0
  813.       ANDFLG=.FALSE.
  814.       BUNFLG=.FALSE.
  815.       DFLAG=(PRSFLG.AND.4).NE.0
  816.  
  817. C SPARSE, PAGE 8
  818. C
  819. C Now loop over input buffer of lexical tokens.
  820. C
  821.       I=0
  822. 10    I=I+1                                     ! do 1000 i=1,llnt
  823.         WORD=LBUF(I)                            ! get current token.
  824.         ERRVOC=0                                ! assume won't find
  825.         IF(WORD.EQ.' ') GO TO 1000              ! blank? ignore.
  826.         IF(WORD.EQ.'AND') GO TO 1500            ! 'AND'?
  827.         IF((WORD.EQ.'EXCEPT').OR.(WORD.EQ.'BUT')) GO TO 2500
  828. C
  829. C Check for buzz word
  830. C
  831.         DO 50 J=1,BWMAX
  832.           IF(WORD.EQ.BWORD(J)) GO TO 1000       ! if match, ignore.
  833. 50      CONTINUE
  834. C
  835. C Check for action or direction
  836. C
  837.         J=1                                     ! check for action.
  838.         DO 70 K=1,VWMAX
  839.           IF(VWORD(K)(1:1).EQ.'*') GO TO 65     ! synonym?
  840.           IF(WORD.EQ.VWORD(K)) GO TO 2000       ! match to base word?
  841.           J=J+VVOC(J)+1                         ! skip over syntax.
  842.           GO TO 70
  843. 65        IF(WORD.EQ.VWORD(K)(2:WRDLNT)) GO TO 2000 ! synonym match?
  844. 70      CONTINUE
  845. C
  846. 75      IF((ADJ.NE.0).OR.(PREP.NE.0).OR.(OBJ1.NE.0)) GO TO 200
  847.         IF(ACT.EQ.0) GO TO 80                   ! any verb yet?
  848.         IF((VVOC(ACT+1).AND.SVMASK).NE.WALKW) GO TO 200 ! walk?
  849. 80      DO 100 J=1,DWMAX                        ! then chk for dir.
  850.           IF(WORD.EQ.DWORD(J)) GO TO 3000       ! match to direction?
  851. 100     CONTINUE
  852. C
  853. C Not an action, check for preposition, adjective, or object.
  854. C
  855. 200     DO 250 J=1,PWMAX                        ! look for preposition.
  856.           IF(WORD.EQ.PWORD(J)) GO TO 4000       ! match to preposition?
  857. 250     CONTINUE
  858. C
  859.         J=1                                     ! look for adjective.
  860.         DO 350 K=1,AWMAX
  861.           IF(WORD.EQ.AWORD(K)) GO TO 5000       ! match to adjective?
  862. 300       J=J+1                                 ! advance to next entry.
  863.           IF(AVOC(J).LT.0) GO TO 300            ! found next entry yet?
  864. 350     CONTINUE
  865. C
  866. 400     J=1                                     ! look for object.
  867.         DO 550 K=1,OWMAX
  868.           IF(WORD.EQ.OWORD(K)) GO TO 6000       ! match to object?
  869. 500       J=J+1                                 ! advance to next entry.
  870.           IF(OVOC(J).LT.0) GO TO 500            ! found next entry yet?
  871. 550     CONTINUE
  872. C
  873. C Not recognizable
  874. C
  875.         IF(.NOT.VBFLAG) RETURN                  ! if mute, return
  876.         LCWORD=LCIFY(WORD,1)                    ! convert to lower case
  877.         WRITE(OUTCH,600) LCWORD(1:NBLEN(LCWORD)) ! don't recognize
  878. 600     FORMAT(' I don''t understand "',A,'".')
  879.         CALL RSPEAK(ERRVOC)                     ! if extra verb, say so
  880. 800     TELFLG=.TRUE.                           ! something said.
  881.         BUNSUB=0                                ! no valid EXCEPT clause.
  882.         RETURN
  883.  
  884. C SPARSE, PAGE 9
  885. C
  886. 1000  IF(I.LT.LLNT) GO TO 10                    ! end of do loop
  887. C
  888. C At end of parse, check for:
  889. C       1. dangling adjective
  890. C       2. bunched object
  891. C       3. simple directions
  892. C       4. orphan preposition
  893. C       5. dangling preposition
  894. C
  895.       IF(ADJ.NE.0) GO TO 4500                   ! dangling adjective?
  896.       IF(BUNFLG) OBJ1=BUNOBJ                    ! bunched object?
  897.       IF(BUNFLG.AND.(BUNSUB.NE.0).AND.(BUNLNT.EQ.0))
  898.      1GO TO 13200                               ! except for nothing?
  899.       IF(ACT.EQ.0) ACT=OFLAG.AND.OACT           ! if no action, take orphan.
  900.       IF(ACT.EQ.0) GO TO 10000                  ! no action, punt.
  901.       IF(((VVOC(ACT+1).AND.SVMASK).NE.WALKW).OR.(OBJ1.LT.XMIN))
  902.      1GO TO 1100                                ! simple direction?
  903.       IF ((OBJ2.NE.0).OR.(PREP1.NE.0).OR.(PREP2.NE.0))
  904.      1GO TO 1050                                ! no extra junk?
  905.       PRSA=WALKW                                ! yes, win totally.
  906.       PRSO=OBJ1
  907.       SPARSE=1                                  ! special return value.
  908.       RETURN
  909. C
  910. 1050  IF(VBFLAG) CALL RSPEAK(618)               ! direction+junk, fail.
  911.       GO TO 800                                 ! clean up state.
  912. C
  913. 1100  IF((OFLAG.NE.0).AND.(OPREP.NE.0).AND.(PREP.EQ.0).AND.
  914.      1(OBJ1.NE.0).AND.(OBJ2.EQ.0).AND.(ACT.EQ.OACT))
  915.      2GO TO 11000
  916. C
  917.       IF(PREP.EQ.0) GO TO 1200                  ! if dangling prep,
  918.       IF(PPTR.EQ.0) GO TO 12000                 ! and no object, die;
  919.       IF(PRPVEC(PPTR).NE.0) GO TO 12000         ! and prep already, die;
  920.       PRPVEC(PPTR)=PREP                         ! cvt to 'pick up frob'.
  921. 1200  SPARSE=0                                  ! parse succeeds.
  922.       IF(DFLAG) WRITE(OUTCH,1310) ACT,OBJ1,OBJ2,PREP1,PREP2
  923. 1310  FORMAT(' SPARSE RESULTS- ',5I7)
  924.       RETURN
  925.  
  926. C SPARSE, PAGE 10
  927. C
  928. C 1500--        AND
  929. C
  930. 1500  IF(ADJ.NE.0) GO TO 4100                   ! dangling adj? treat as obj.
  931.       IF((PREP.NE.0).OR.(PPTR.NE.1)) GO TO 8000 ! prep or not dir obj?
  932.       ANDFLG=.TRUE.                             ! flag 'AND'.
  933.       GO TO 1000                                ! done.
  934. C
  935. C 2000--        Action
  936. C
  937. 2000  IF(ACT.EQ.0) GO TO 2100                   ! got one already?
  938.       ERRVOC=624                                ! flag for error report.
  939.       GO TO 75                                  ! try to construe differently.
  940. C
  941. 2100  ACT=J                                     ! save index to verb.
  942.       OACT=0                                    ! no orphan.
  943.       ANDFLG=.FALSE.                            ! clear 'AND' flag.
  944.       IF(DFLAG) WRITE(OUTCH,2020) J
  945. 2020  FORMAT(' SPARSE- ACT AT ',I6)
  946.       GO TO 1000                                ! done.
  947. C
  948. C 2500--        EXCEPT/BUT
  949. C
  950. 2500  IF(ADJ.NE.0) GO TO 4100                   ! dangling adjective?
  951.       IF(ANDFLG.OR.BUNFLG.OR.(PPTR.NE.1).OR.
  952.      1(I.GE.LLNT)) GO TO 13000                  ! not in right place?
  953.       IF(LBUF(I+1).NE.'FOR') GO TO 2600         ! except for?
  954.       I=I+1                                     ! skip over.
  955.       IF(I.GE.LLNT) GO TO 13000                 ! out of text?
  956. 2600  IF((OBJ1.NE.EVERY).AND.(OBJ1.NE.VALUA).AND.
  957.      1 (OBJ1.NE.POSSE)) GO TO 13100             ! "collective" EXCEPT?
  958.       ANDFLG=.TRUE.                             ! force next object
  959.       BUNFLG=.TRUE.                             ! into bunch vector.
  960.       BUNLNT=0                                  ! start at top.
  961.       BUNSUB=OBJ1                               ! remember collective.
  962.       GO TO 1000                                ! on to next word.
  963. C
  964. C 3000--        Direction
  965. C               Don't need to check for ambiguous use as adjective;
  966. C               only possible overlap is north/south/east/west wall;
  967. C               and global wall takes is found if no adjective given.
  968. C
  969. 3000  OBJ=DVOC(J)                               ! save direction.
  970.       ACT=1                                     ! find value for action.
  971. 3600  IF(VVOC(ACT).EQ.0) CALL BUG(310,ACT)      ! can't find walk.
  972.       IF((VVOC(ACT+1).AND.SVMASK).EQ.WALKW) GO TO 6300 ! treat as obj.
  973.       ACT=ACT+VVOC(ACT)+1                       ! to next syntax entry.
  974.       GO TO 3600
  975. C
  976. C 4000--        Preposition (or dangling adjective at end of parse)
  977. C
  978. 4000  IF(ADJ.EQ.0) GO TO 4600                   ! dangling adjective?
  979. 4100  I=I-1                                     ! back up parse stream.
  980. 4500  WORD=AWORD(ADJPTR)                        ! get adjective string.
  981.       ADJ=0                                     ! now an object.
  982.       GO TO 400                                 ! go search object words.
  983. C
  984. 4600  IF(ANDFLG) GO TO 8000                     ! 'AND' pending?
  985.       IF(PREP.NE.0) GO TO 1000                  ! already have one? ignore.
  986.       PREP=PVOC(J)                              ! no, get index.
  987.       IF(DFLAG) WRITE(OUTCH,4030) J
  988. 4030  FORMAT(' SPARSE- PREP AT ',I6)
  989.       GO TO 1000
  990. C
  991. C 5000--        Adjective
  992. C
  993. 5000  ADJ=J                                     ! save adjective.
  994.       ADJPTR=K                                  ! save string pointer.
  995.       IF((I.LT.LLNT).OR.(OFLAG.EQ.0).OR.(ONAME.EQ.' '))
  996.      1GO TO 1000                                ! last word + orphan string?
  997.       IF(DFLAG) WRITE(OUTCH,5040) ADJ,ONAME     ! have orphan.
  998. 5040  FORMAT(' SPARSE- ADJ AT ',I6,' ORPHAN= ',A)
  999.       WORD=ONAME                                ! get object string.
  1000.       GO TO 400                                 ! go search object names.
  1001. C
  1002. C 6000--        Object
  1003. C
  1004. 6000  OBJ=GETOBJ(J,ADJ,0)                       ! identify object.
  1005.       IF(DFLAG) WRITE(OUTCH,6010) J,OBJ
  1006. 6010  FORMAT(' SPARSE- OBJ AT ',I6,'  OBJ= ',I6)
  1007.       IF(OBJ.LE.0) GO TO 7000                   ! if le, couldnt.
  1008.       IF(OBJ.NE.ITOBJ) GO TO 6100               ! "it"?
  1009.       IF((OFLAG.AND.OOBJ1).NE.0) LASTIT=OFLAG.AND.OOBJ1 ! orphan?
  1010.       OBJ=GETOBJ(0,0,LASTIT)                    ! find it.
  1011.       IF(OBJ.LE.0) GO TO 7500                   ! if le, couldnt.
  1012. C
  1013. 6100  IF(PREP.NE.9) GO TO 6200                  ! "of" obj?
  1014.       IF((LOBJ.EQ.OBJ).OR.(LOBJ.EQ.OCAN(OBJ))) GO TO 6500 ! same as prev?
  1015.       IF((LOBJ.EQ.EVERY).AND.((OBJ.EQ.VALUA).OR.(OBJ.EQ.POSSE)))
  1016.      1GO TO 6350                                ! all of "collective"?
  1017. 6150  IF(VBFLAG) CALL RSPEAK(601)               ! doesn't work
  1018.       GO TO 800                                 ! clean up state.
  1019. C
  1020. 6200  IF(.NOT.ANDFLG) GO TO 6300                ! 'AND' pending?
  1021.       IF(BUNFLG) GO TO 6250                     ! first object?
  1022.       BUNVEC(1)=OBJVEC(PPTR)                    ! put preceding obj in vector.
  1023.       BUNLNT=1
  1024.       BUNFLG=.TRUE.                             ! flag bunch of objects.
  1025.       BUNSUB=0                                  ! no EXCEPT/BUT clause.
  1026. 6250  BUNLNT=BUNLNT+1                           ! advance bunch pointer.
  1027.       IF(BUNLNT.GT.BUNMAX) GO TO 9000           ! too many objects?
  1028.       BUNVEC(BUNLNT)=OBJ                        ! add to bunch vector.
  1029.       GO TO 6500
  1030. C
  1031. 6300  IF(PPTR.EQ.2) GO TO 9000                  ! too many objs?
  1032.       PPTR=PPTR+1
  1033.       PRPVEC(PPTR)=PREP
  1034. 6350  OBJVEC(PPTR)=OBJ                          ! stuff into vector.
  1035. 6500  PREP=0
  1036.       ADJ=0
  1037.       ANDFLG=.FALSE.                            ! no pending 'AND'.
  1038.       LOBJ=OBJ                                  ! record last object.
  1039.       GO TO 1000
  1040.  
  1041. C SPARSE, PAGE 11
  1042. C
  1043. C 7000--        Unidentifiable object (index into OVOC is J)
  1044. C
  1045. 7000  LCWORD=LCIFY(WORD,1)                      ! convert obj to lower case.
  1046.       LCWRD1=' '                                ! assume no adjective
  1047.       IF(ADJ.NE.0) LCWRD1=' '//LCIFY(AWORD(ADJPTR),1)//' '
  1048.       IF(OBJ.LT.0) GO TO 7200                   ! ambiguous or unreachable?
  1049.       IF(LIT(HERE)) GO TO 7100                  ! lit?
  1050.       IF(VBFLAG) CALL RSPEAK(579)               ! not lit, report.
  1051.       GO TO 800                                 ! go clean up state.
  1052. C
  1053. 7100  IF(VBFLAG) WRITE(OUTCH,7110)
  1054.      1LCWRD1(1:NBLEN(LCWRD1)+1),LCWORD(1:NBLEN(LCWORD))
  1055. 7110  FORMAT(' I can''t see any',A,A,' here.')
  1056.       GO TO 800                                 ! go clean up state.
  1057. C
  1058. 7200  IF(OBJ.NE.-10000) GO TO 7300              ! inside vehicle?
  1059.       IF(VBFLAG) CALL RSPSUB(620,ODESC2(AVEHIC(WINNER)))
  1060.       GO TO 800                                 ! go clean up state.
  1061. C
  1062. 7300  IF(ACT.EQ.0) ACT=OFLAG.AND.OACT           ! if no act, get orphan.
  1063.       CALL ORPHAN(-1,ACT,PREP1,OBJ1,PREP,WORD,0,0) ! orphan the world.
  1064.       IF(VBFLAG) WRITE(OUTCH,7310)
  1065.      1LCWRD1(1:NBLEN(LCWRD1)+1),LCWORD(1:NBLEN(LCWORD))
  1066. 7310  FORMAT(' Which',A,A,' do you mean?')
  1067.       GO TO 800                                 ! go clean up state.
  1068. C
  1069. C 7500--        Unidentifiable 'IT' (last direct object is LASTIT).
  1070. C
  1071. 7500  IF(OBJ.LT.0) GO TO 7200                   ! if lt, must be unreachable.
  1072.       IF(LIT(HERE)) GO TO 7600                  ! lit?
  1073.       IF(VBFLAG) CALL RSPEAK(1076)              ! lose.
  1074.       GO TO 800                                 ! go clean up state.
  1075. C
  1076. 7600  IF(VBFLAG) CALL RSPSUB(1077,ODESC2(LASTIT)) ! don't see it.
  1077.       GO TO 800                                 ! go clean up state.
  1078. C
  1079. C 8000--        Misplaced 'AND'.
  1080. C
  1081. 8000  IF(VBFLAG) CALL RSPEAK(1049)
  1082.       GO TO 800                                 ! go clean up state.
  1083. C
  1084. C 9000--        Too many objects.
  1085. C
  1086. 9000  IF(VBFLAG) CALL RSPEAK(617)
  1087.       GO TO 800                                 ! go clean up state.
  1088. C
  1089. C 10000--       No action, punt.
  1090. C
  1091. 10000 IF(OBJ1.EQ.0) GO TO 10100                 ! any direct object?
  1092.       IF(VBFLAG) CALL RSPSUB(621,ODESC2(OBJ1))          ! what to do?
  1093.       CALL ORPHAN(-1,0,PREP1,OBJ1,0,' ',0,0)
  1094.       RETURN
  1095. C
  1096. 10100 IF(VBFLAG) CALL RSPEAK(622)               ! huh?
  1097.       GO TO 800                                 ! go clean up state.
  1098. C
  1099. C 11000--       Orphan preposition.  Conditions are
  1100. C               OBJ1.NE.0, OBJ2=0, PREP=0, ACT=OACT
  1101. C
  1102. 11000 IF(OOBJ1.NE.0) GO TO 11500                ! orphan object?
  1103.       PREP1=OPREP                               ! no, just use prep.
  1104.       GO TO 1200
  1105. C
  1106. 11500 OBJ2=OBJ1                                 ! yes, use as direct obj.
  1107.       PREP2=OPREP
  1108.       OBJ1=OOBJ1
  1109.       PREP1=OPREP1
  1110.       GO TO 1200
  1111. C
  1112. C 12000--       True hanging preposition, no objects yet.
  1113. C
  1114. 12000 CALL ORPHAN(-1,ACT,0,0,PREP,' ',0,0)      ! orphan prep.
  1115.       GO TO 1200
  1116. C
  1117. C 13000--       EXCEPT/BUT errors.
  1118. C
  1119. 13000 LCWORD=LCIFY(WORD,1)
  1120.       IF(VBFLAG) WRITE(OUTCH,13010) LCWORD(1:NBLEN(LCWORD)) ! wrong place.
  1121. 13010 FORMAT(' Misplaced "',A,'".')
  1122.       GO TO 800                                 ! go clean up state.
  1123. C
  1124. 13100 LCWORD=LCIFY(WORD,2)                       ! wrong case.
  1125.       IF(VBFLAG) WRITE(OUTCH,13110) LCWORD(1:NBLEN(LCWORD)) ! not coll.
  1126. 13110 FORMAT(' "',A,'" can only be used with "everything",',
  1127.      1' "valuables", or "possessions".')
  1128.       GO TO 800                                 ! go clean up state.
  1129. C
  1130. 13200 IF(VBFLAG) CALL RSPEAK(619)               ! no objects.
  1131.       GO TO 800                                 ! go clean up state.
  1132. C
  1133.       END
  1134.  
  1135. C GETOBJ--      Find obj described by adj, name pair
  1136. C
  1137. C Declarations
  1138. C
  1139. C This routine details on bit 3 of PRSFLG
  1140. C
  1141.       INTEGER FUNCTION GETOBJ(OIDX,AIDX,SPCOBJ)
  1142.       IMPLICIT INTEGER(A-Z)
  1143.       INCLUDE 'dparam.for'
  1144.       LOGICAL THISIT,GHERE,LIT,CHOMP,DFLAG,NOADJS
  1145. C
  1146.       DFLAG=(PRSFLG.AND.8).NE.0
  1147.       CHOMP=.FALSE.
  1148.       AV=AVEHIC(WINNER)
  1149.       OBJ=0                                     ! assume dark.
  1150.       IF(.NOT.LIT(HERE)) GO TO 200              ! lit?
  1151. C
  1152.       OBJ=SCHLST(OIDX,AIDX,HERE,0,0,SPCOBJ)     ! search room.
  1153.       IF(DFLAG) WRITE(OUTCH,10) OBJ
  1154. 10    FORMAT(' SCHLST- ROOM SCH ',I6)
  1155.       IF(OBJ) 1000,200,100                      ! test result.
  1156. 100   IF((AV.EQ.0).OR.(AV.EQ.OBJ).OR.(OCAN(OBJ).EQ.AV).OR.
  1157.      1((OFLAG2(OBJ).AND.FINDBT).NE.0)) GO TO 200
  1158.       CHOMP=.TRUE.                              ! not reachable.
  1159. C
  1160. 200   IF(AV.EQ.0) GO TO 400                     ! in vehicle?
  1161.       NOBJ=SCHLST(OIDX,AIDX,0,AV,0,SPCOBJ)      ! search vehicle.
  1162.       IF(DFLAG) WRITE(OUTCH,220) NOBJ
  1163. 220   FORMAT(' SCHLST- VEH SCH  ',I6)
  1164.       IF(NOBJ) 800,400,300                      ! test result.
  1165. 300   CHOMP=.FALSE.                             ! reachable.
  1166.       IF(OBJ.EQ.NOBJ) GO TO 400                 ! same as before?
  1167.       IF(OBJ.NE.0) NOBJ=-NOBJ                   ! amb result?
  1168.       OBJ=NOBJ
  1169. C
  1170. 400   NOBJ=SCHLST(OIDX,AIDX,0,0,WINNER,SPCOBJ)          ! search adventurer.
  1171.       IF(DFLAG) WRITE(OUTCH,430) NOBJ
  1172. 430   FORMAT(' SCHLST- ADV SCH  ',I6)
  1173.       IF(NOBJ) 800,900,500                      ! test result
  1174. 500   IF(OBJ.EQ.0) GO TO 800                    ! any previous? no, use nobj.
  1175.       IF(AIDX.NE.0) GO TO 600                   ! yes, amb, any adj?
  1176.       IF(NOADJS(OBJ).NEQV.NOADJS(NOBJ)) GO TO 700 ! both adj or no adj?
  1177. 600   OBJ=-NOBJ                                 ! ambiguous result.
  1178.       GO TO 900
  1179. 700   IF(NOADJS(OBJ)) GO TO 900                 ! if old no adj, use old.
  1180. 800   OBJ=NOBJ                                  ! return new object.
  1181. 900   IF(CHOMP) OBJ=-10000                      ! unreachable.
  1182. 1000  GETOBJ=OBJ
  1183. C
  1184.       IF(GETOBJ.NE.0) GO TO 1500                ! got something?
  1185.       DO 1200 I=STRBIT+1,OLNT                   ! no, search globals.
  1186.         IF(.NOT.THISIT(OIDX,AIDX,I,SPCOBJ)) GO TO 1200
  1187.         IF(.NOT.GHERE(I,HERE)) GO TO 1200       ! can it be here?
  1188.         IF(GETOBJ.EQ.0) GO TO 1150              ! got one yet?
  1189.         IF(AIDX.NE.0) GO TO 1050                ! yes, no adj?
  1190.         IF(NOADJS(GETOBJ).NEQV.NOADJS(I)) GO TO 1100 ! only one with no adj?
  1191. 1050    GETOBJ=-I                               ! ambiguous
  1192.         GO TO 1200
  1193. 1100    IF(NOADJS(GETOBJ)) GO TO 1200           ! if old no adj, retain.
  1194. 1150    GETOBJ=I                                ! new is target.
  1195. 1200  CONTINUE
  1196. C
  1197. 1500  CONTINUE                                  ! end of search.
  1198.       IF(DFLAG) WRITE(OUTCH,1540) GETOBJ
  1199. 1540  FORMAT(' SCHLST- RESULT   ',I6)
  1200.       RETURN
  1201.       END
  1202.  
  1203. C SCHLST--      Search for object
  1204. C
  1205. C Declarations
  1206. C
  1207.       INTEGER FUNCTION SCHLST(OIDX,AIDX,RM,CN,AD,SPCOBJ)
  1208.       IMPLICIT INTEGER(A-Z)
  1209.       INCLUDE 'dparam.for'
  1210.       LOGICAL THISIT,QHERE,NOTRAN,NOVIS,AEMPTY,NOADJS
  1211. C
  1212. C Functions and data
  1213. C
  1214.       NOTRAN(O)=((OFLAG1(O).AND.TRANBT).EQ.0).AND.
  1215.      1((OFLAG2(O).AND.OPENBT).EQ.0)
  1216.       NOVIS(O)=((OFLAG1(O).AND.VISIBT).EQ.0)
  1217. C
  1218.       SCHLST=0                                  ! no result.
  1219.       AEMPTY=.FALSE.                            ! no ambiguous empty.
  1220.       DO 1000 I=1,OLNT                          ! search objects.
  1221.         IF(NOVIS(I).OR.
  1222.      1(((RM.EQ.0).OR.(.NOT.QHERE(I,RM))).AND.
  1223.      2 ((CN.EQ.0).OR.(OCAN(I).NE.CN)).AND.
  1224.      3 ((AD.EQ.0).OR.(OADV(I).NE.AD)))) GO TO 1000
  1225.         IF(.NOT.THISIT(OIDX,AIDX,I,SPCOBJ)) GO TO 200
  1226.         IF(SCHLST.EQ.0) GO TO 150               ! got one already?
  1227.         IF(AIDX.NE.0) GO TO 2000                ! adj? then ambiguous
  1228.         IF(NOADJS(I)) GO TO 100                 ! new have no adj?
  1229.         AEMPTY=.TRUE.                           ! no, old might, flag.
  1230.         GO TO 200
  1231. 100     IF(NOADJS(SCHLST)) GO TO 2000           ! old have no adj?
  1232. 150     SCHLST=I                                ! new is unique, or
  1233.                                            ! new has no adj, old does.
  1234. C
  1235. C If open or transparent, search the object itself.
  1236. C
  1237. 200     IF(NOTRAN(I)) GO TO 1000
  1238. C
  1239. C Search is conducted in reverse.  All objects are checked to
  1240. C See if they are at some level of containment inside object 'I'.
  1241. C If they are at level 1, or if all links in the containment
  1242. C chain are open, visible, and have SEARCHME set, they can qualify
  1243. C as a potential match.
  1244. C
  1245.         DO 500 J=1,OLNT                         ! search objects.
  1246.           IF(NOVIS(J).OR. (.NOT.THISIT(OIDX,AIDX,J,SPCOBJ)))
  1247.      1GO TO 500                                 ! visible & match?
  1248.           X=OCAN(J)                             ! get container.
  1249. 300       IF(X.EQ.I) GO TO 400                  ! inside target?
  1250.           IF(X.EQ.0) GO TO 500                  ! inside anything?
  1251.           IF(NOVIS(X).OR.NOTRAN(X).OR.
  1252.      1((OFLAG2(X).AND.SCHBT).EQ.0)) GO TO 500
  1253.           X=OCAN(X)                             ! go another level.
  1254.           GO TO 300
  1255. C
  1256. 400       IF(SCHLST.EQ.0) GO TO 450             ! already got one?
  1257.           IF(AIDX.NE.0) GO TO 2000              ! adj? then ambiguous.
  1258.           IF(NOADJS(J)) GO TO 425               ! new have no adj?
  1259.           AEMPTY=.TRUE.                         ! no, ambiguous empty.
  1260.           GO TO 500
  1261. 425       IF(NOADJS(SCHLST)) GO TO 2000         ! old have no adj? then amb.
  1262. 450       SCHLST=J                              ! new is unique, or
  1263.                                            ! new has no adj, and old does.
  1264. 500     CONTINUE
  1265. C
  1266. 1000  CONTINUE
  1267.       IF(.NOT.AEMPTY.OR.(SCHLST.EQ.0)) RETURN   ! if none or not amb, done.
  1268.       IF(NOADJS(SCHLST)) RETURN                 ! if amb, and no adj, done.
  1269. 2000  SCHLST=-SCHLST                            ! amb return.
  1270.       RETURN
  1271. C
  1272.       END
  1273.  
  1274. C THISIT--      Validate object vs description
  1275. C
  1276. C Declarations
  1277. C
  1278.       LOGICAL FUNCTION THISIT(OIDX,AIDX,OBJ,SPCOBJ)
  1279.       IMPLICIT INTEGER(A-Z)
  1280.       INCLUDE 'dparam.for'
  1281. C
  1282.       THISIT=.FALSE.                            ! assume no match.
  1283.       IF((SPCOBJ.NE.0).AND.(OBJ.EQ.SPCOBJ)) GO TO 500
  1284. C
  1285. C Check for object names
  1286. C
  1287.       IF(OIDX.EQ.0) RETURN                      ! no obj? lose.
  1288.       I=OIDX
  1289. 100   IF(IABS(OVOC(I)).EQ.OBJ) GO TO 200        ! found it?
  1290.       I=I+1                                     ! adv to next.
  1291.       IF(OVOC(I).LT.0) GO TO 100                ! still part of list?
  1292.       RETURN                                    ! if done, lose.
  1293. C
  1294. 200   IF(AIDX.EQ.0) GO TO 500                   ! no adj? done.
  1295.       I=AIDX
  1296. 300   IF(IABS(AVOC(I)).EQ.OBJ) GO TO 500        ! found it?
  1297.       I=I+1                                     ! adv to next.
  1298.       IF(AVOC(I).LT.0) GO TO 300                ! still part of list?
  1299.       RETURN                                    ! if done, lose.
  1300. C
  1301. 500   THISIT=.TRUE.
  1302.       RETURN
  1303.       END
  1304.  
  1305. C SYNMCH--      Syntax matcher
  1306. C
  1307. C Declarations
  1308. C
  1309. C This routine details on bit 4 of PRSFLG
  1310. C
  1311.       LOGICAL FUNCTION SYNMCH(X)
  1312.       IMPLICIT INTEGER(A-Z)
  1313.       INCLUDE 'dparam.for'
  1314.       LOGICAL SYNEQL,TAKEIT,DFLAG
  1315.       CHARACTER*(TEXLNT) STR
  1316.       CHARACTER*(WRDLNT) FINDVB,FINDPR,LCIFY,LCWORD
  1317.       CHARACTER*(WRDLNT+2) LCPRP1,LCPRP2
  1318.  
  1319. C SYNMCH, PAGE 2
  1320. C
  1321.       SYNMCH=.FALSE.
  1322.       DFLAG=(PRSFLG.AND.16).NE.0
  1323.       J=ACT                                     ! set up ptr to syntax.
  1324.       DRIVE=0                                   ! no default.
  1325.       DFORCE=0                                  ! no forced default.
  1326.       QPREP=OFLAG.AND.OPREP                     ! valid orphan prep flag.
  1327.       LIMIT=J+VVOC(J)+1                         ! compute limit.
  1328.       J=J+1                                     ! advance to next.
  1329. C
  1330. 200   CALL UNPACK(J,NEWJ)                       ! unpack syntax.
  1331.       IF(DFLAG) WRITE(OUTCH,210) J,OBJ1,PREP1,DOBJ,DFL1,DFL2
  1332. 210   FORMAT(' SYNMCH DOBJ INPUTS TO SYNEQL- ',6I7)
  1333.       SPREP=DOBJ.AND.VPMASK                     ! save expected prep.
  1334.       IF(SYNEQL(PREP1,OBJ1,DOBJ,DFL1,DFL2)) GO TO 1000
  1335. C
  1336. C Direct syntax match fails, try direct as indirect.
  1337. C
  1338.       IF((OBJ2.NE.0).OR.(OBJ1.EQ.0).OR.
  1339.      1(.NOT.SYNEQL(PREP1,OBJ1,IOBJ,IFL1,IFL2)))
  1340.      2GO TO 500                                 ! try direct as indirect.
  1341.       OBJ2=OBJ1                                 ! move direct to indirect.
  1342.       PREP2=PREP1
  1343.       OBJ1=0                                    ! no direct.
  1344.       PREP1=0
  1345.       DRIVE=J                                   ! save as driver.
  1346.       GO TO 3100                                ! go try to get direct obj
  1347. C
  1348. C Direct syntax match and direct-as-indirect fail.
  1349. C
  1350. 500   IF(OBJ1.NE.0) GO TO 3000                  ! if direct obj, on to next.
  1351.       GO TO 2500                                ! go do defaults.
  1352. C
  1353. C Direct syntax match succeeded, try indirect.
  1354. C
  1355. 1000  IF(DFLAG) WRITE(OUTCH,1010) J,OBJ2,PREP2,IOBJ,IFL1,IFL2
  1356. 1010  FORMAT(' SYNMCH IOBJ INPUTS TO SYNEQL- ',6I7)
  1357.       SPREP=IOBJ.AND.VPMASK                     ! save expected prep.
  1358.       IF(SYNEQL(PREP2,OBJ2,IOBJ,IFL1,IFL2)) GO TO 6000
  1359. C
  1360. C Indirect syntax match fails.
  1361. C
  1362.       IF(OBJ2.NE.0) GO TO 3000                  ! if ind object, on to next.
  1363. 2500  IF((QPREP.EQ.0).OR.(QPREP.EQ.SPREP)) DFORCE=J      ! if prep mch.
  1364.       IF((VFLAG.AND.SDRIV).NE.0) DRIVE=J        ! if driver, record.
  1365.       IF(DFLAG) WRITE(OUTCH,2510) J,QPREP,SPREP,DFORCE,DRIVE
  1366. 2510  FORMAT(' SYNMCH DEFAULT SYNTAXES- ',5I7)
  1367. 3000  J=NEWJ
  1368.       IF(J.LT.LIMIT) GO TO 200                  ! more to do?
  1369.  
  1370. C SYNMCH, PAGE 3
  1371. C
  1372. C Match has failed.  If default syntax exists, try to snarf
  1373. C orphans or GWIMs, or make new orphans.
  1374. C
  1375. 3100  IF(DFLAG) WRITE(OUTCH,3110) DRIVE,DFORCE,OBJ1,OBJ2
  1376. 3110  FORMAT(' SYNMCH, DRIVE=',2I6,'  OBJECTS =',2I6)
  1377.       IF(DRIVE.EQ.0) DRIVE=DFORCE               ! no driver? use force.
  1378.       IF(DRIVE.EQ.0) GO TO 10000                ! any driver?
  1379.       CALL UNPACK(DRIVE,DFORCE)                 ! unpack dflt syntax.
  1380.       LCWORD=LCIFY(FINDVB(DRIVE),2)             ! get verb string.
  1381.       LCPRP1=' '//LCIFY(FINDPR(DOBJ.AND.VPMASK),1)//' '
  1382.       LCPRP2=' '//LCIFY(FINDPR(IOBJ.AND.VPMASK),1)//' '
  1383. C
  1384. C Try to fill direct object slot if that was the problem.
  1385. C
  1386.       IF(((VFLAG.AND.SDIR).EQ.0).OR.(OBJ1.NE.0)) GO TO 4000
  1387.       OBJ1=OFLAG.AND.OOBJ1
  1388.       IF(OBJ1.EQ.0) GO TO 3500                  ! any orphan?
  1389.       IF(SYNEQL(OPREP1,OBJ1,DOBJ,DFL1,DFL2)) GO TO 4000
  1390. C
  1391. C Orphan fails, try GWIM.
  1392. C
  1393. 3500  OBJ1=GWIM(DOBJ,DFW1,DFW2)                 ! get gwim.
  1394.       IF(DFLAG) WRITE(OUTCH,3530) OBJ1
  1395. 3530  FORMAT(' SYNMCH- DO GWIM= ',I6)
  1396.       IF(OBJ1.GT.0) GO TO 4000                  ! test result.
  1397.       CALL ORPHAN(-1,ACT,0,0,DOBJ.AND.VPMASK,' ',PREP2,OBJ2) ! fails, orphan.
  1398.       BUNSUB=0                                  ! no EXCEPT clause.
  1399.       IF(OBJ2.GT.0) GO TO 3800                  ! if iobj, go print.
  1400. 3700  WRITE(OUTCH,3750)
  1401.      1LCWORD(1:NBLEN(LCWORD)),LCPRP1(1:NBLEN(LCPRP1)+1)
  1402. 3750  FORMAT(1X,A,A,'what?')
  1403.       TELFLG=.TRUE.
  1404.       RETURN
  1405. C
  1406. 3800  X=IABS(ODESC2(OBJ2))                      ! get iobj description.
  1407.       READ(DBCH,REC=X) J,STR                    ! read data base.
  1408.       CALL TXCRYP(X,STR)                        ! decrypt the line.
  1409.       WRITE(OUTCH,3880) LCWORD(1:NBLEN(LCWORD)),
  1410.      1LCPRP1(1:NBLEN(LCPRP1)+1),
  1411.      2LCPRP2(1:NBLEN(LCPRP2)+1),STR(1:NBLEN(STR))
  1412. 3880  FORMAT(1X,A,A,'what',A,'the ',A,'?')
  1413.       TELFLG=.TRUE.
  1414.       RETURN
  1415.  
  1416. C SYNMCH, PAGE 4
  1417. C
  1418. C Try to fill indirect object slot if that was the problem.
  1419. C
  1420. 4000  IF(((VFLAG.AND.SIND).EQ.0).OR.(OBJ2.NE.0)) GO TO 6000
  1421.       OBJ2=OFLAG.AND.OOBJ2
  1422.       IF(OBJ2.EQ.0) GO TO 4500                  ! any orphan?
  1423.       IF(SYNEQL(OPREP2,OBJ2,IOBJ,IFL1,IFL2)) GO TO 6000
  1424. C
  1425. C Orphan fails, try GWIM.
  1426. C
  1427. 4500  OBJ2=GWIM(IOBJ,IFW1,IFW2)                 ! gwim.
  1428.       IF(DFLAG) WRITE(OUTCH,4550) OBJ2
  1429. 4550  FORMAT(' SYNMCH- IO GWIM= ',I6)
  1430.       IF(OBJ2.GT.0) GO TO 6000
  1431.       IF(OBJ1.GT.0) GO TO 4600                  ! if dobj, go print.
  1432.       CALL ORPHAN(-1,ACT,OFLAG.AND.OPREP1,
  1433.      1OFLAG.AND.OOBJ1,IOBJ.AND.VPMASK,' ',0,0)
  1434.       GO TO 3700
  1435. C
  1436. C Error with direct object available.
  1437. C
  1438. 4600  CALL ORPHAN(-1,ACT,PREP1,OBJ1,IOBJ.AND.VPMASK,' ',0,0)
  1439.       X=IABS(ODESC2(OBJ1))                      ! get dobj description.
  1440.       READ(DBCH,REC=X) J,STR                    ! read data base.
  1441.       CALL TXCRYP(X,STR)                        ! decrypt the line.
  1442.       WRITE(OUTCH,4660) LCWORD(1:NBLEN(LCWORD)),
  1443.      1LCPRP1(1:NBLEN(LCPRP1)+1),
  1444.      2STR(1:NBLEN(STR)),LCPRP2(1:NBLEN(LCPRP2)+1)
  1445. 4660  FORMAT(1X,A,A,'the ',A,A,'what?')
  1446.       TELFLG=.TRUE.
  1447.       RETURN
  1448. C
  1449. C Total chomp.
  1450. C
  1451. 10000 CALL RSPEAK(601)                          ! cant do anything.
  1452.       BUNSUB=0
  1453.       RETURN
  1454.  
  1455. C SYNMCH, PAGE 5
  1456. C
  1457. C Now try to take individual objects and
  1458. C in general clean up the parse vector.
  1459. C
  1460. 6000  IF((VFLAG.AND.SFLIP).EQ.0) GO TO 7000     ! flip?
  1461.       J=OBJ1                                    ! yes.
  1462.       OBJ1=OBJ2
  1463.       OBJ2=J
  1464. C
  1465. 7000  PRSA=VFLAG.AND.SVMASK                     ! get verb.
  1466.       PRSO=OBJ1                                 ! get dir obj.
  1467.       PRSI=OBJ2                                 ! get ind obj.
  1468.       IF(.NOT.TAKEIT(PRSO,DOBJ)) RETURN         ! try take.
  1469.       IF(.NOT.TAKEIT(PRSI,IOBJ)) RETURN         ! try take.
  1470.       SYNMCH=.TRUE.
  1471.       IF(DFLAG) WRITE(OUTCH,7050) SYNMCH,PRSA,PRSO,PRSI,ACT,OBJ1,OBJ2
  1472. 7050  FORMAT(' SYNMCH- RESULTS ',L1,6I7)
  1473.       RETURN
  1474. C
  1475.       END
  1476.  
  1477. C UNPACK-       Unpack syntax specification, adv pointer
  1478. C
  1479. C Declarations
  1480. C
  1481.       SUBROUTINE UNPACK(OLDJ,J)
  1482.       IMPLICIT INTEGER(A-Z)
  1483.       INCLUDE 'dparam.for'
  1484. C
  1485.       DO 10 I=1,11                              ! clear syntax.
  1486.         SYN(I)=0
  1487. 10    CONTINUE
  1488. C
  1489.       VFLAG=VVOC(OLDJ)
  1490.       J=OLDJ+1
  1491.       IF((VFLAG.AND.SDIR).EQ.0) RETURN          ! dir object?
  1492.       DFL1=-1                                   ! assume std.
  1493.       DFL2=-1
  1494.       IF((VFLAG.AND.SSTD).EQ.0) GO TO 100       ! std object?
  1495.       DFW1=-1                                   ! yes.
  1496.       DFW2=-1
  1497.       DOBJ=VABIT+VRBIT+VFBIT
  1498.       GO TO 200
  1499. C
  1500. 100   DOBJ=VVOC(J)                              ! not std.
  1501.       DFW1=VVOC(J+1)
  1502.       DFW2=VVOC(J+2)
  1503.       J=J+3
  1504.       IF((DOBJ.AND.VEBIT).EQ.0) GO TO 200       ! vbit = vfwim?
  1505.       DFL1=DFW1                                 ! yes.
  1506.       DFL2=DFW2
  1507. C
  1508. 200   IF((VFLAG.AND.SIND).EQ.0) RETURN          ! ind object?
  1509.       IFL1=-1                                   ! assume std.
  1510.       IFL2=-1
  1511.       IOBJ=VVOC(J)
  1512.       IFW1=VVOC(J+1)
  1513.       IFW2=VVOC(J+2)
  1514.       J=J+3
  1515.       IF((IOBJ.AND.VEBIT).EQ.0) RETURN          ! vbit = vfwim?
  1516.       IFL1=IFW1                                 ! yes.
  1517.       IFL2=IFW2
  1518.       RETURN
  1519. C
  1520.       END
  1521.  
  1522. C SYNEQL-       Test for syntax equality
  1523. C
  1524. C Declarations
  1525. C
  1526.       LOGICAL FUNCTION SYNEQL(PREP,OBJ,SPREP,SFL1,SFL2)
  1527.       IMPLICIT INTEGER(A-Z)
  1528.       INCLUDE 'dparam.for'
  1529. C
  1530.       IF(OBJ.EQ.0) GO TO 100                    ! any object?
  1531.       SYNEQL=(PREP.EQ.(SPREP.AND.VPMASK)).AND.
  1532.      1(((SFL1.AND.OFLAG1(OBJ)).OR.
  1533.      2  (SFL2.AND.OFLAG2(OBJ))).NE.0)
  1534.       RETURN
  1535. C
  1536. 100   SYNEQL=(PREP.EQ.0).AND.(SFL1.EQ.0).AND.(SFL2.EQ.0)
  1537.       RETURN
  1538. C
  1539.       END
  1540.  
  1541. C TAKEIT-       Parser based take of object
  1542. C
  1543. C Declarations
  1544. C
  1545.       LOGICAL FUNCTION TAKEIT(OBJ,SFLAG)
  1546.       IMPLICIT INTEGER(A-Z)
  1547.       INCLUDE 'dparam.for'
  1548.       LOGICAL TAKE,LIT
  1549. C
  1550.       TAKEIT=.FALSE.                            ! assume loses.
  1551.       IF((OBJ.EQ.0).OR.(OBJ.GT.STRBIT).OR.DEADF)
  1552.      1GO TO 4000                                ! null/stars/dead win.
  1553.       ODO2=ODESC2(OBJ)                          ! get desc.
  1554.       X=OCAN(OBJ)                               ! get container.
  1555.       IF((X.EQ.0).OR.((SFLAG.AND.VFBIT).EQ.0)) GO TO 500
  1556.       IF((OFLAG2(X).AND.OPENBT).NE.0) GO TO 500
  1557.       CALL RSPSUB(566,ODO2)                     ! cant reach.
  1558.       RETURN
  1559. C
  1560. 500   IF((SFLAG.AND.VRBIT).EQ.0) GO TO 1000     ! shld be in room?
  1561.       IF((SFLAG.AND.VTBIT).EQ.0) GO TO 2000     ! can be taken?
  1562. C
  1563. C Should be in room (VRBIT NE 0) and can be taken (VTBIT NE 0)
  1564. C
  1565.       IF(SCHLST(0,0,HERE,0,0,OBJ).LE.0) GO TO 4000 ! if not, ok.
  1566. C
  1567. C Its in the room and can be taken.
  1568. C
  1569.       IF((OFLAG1(OBJ).AND.TAKEBT).NE.0) GO TO 3000
  1570. C
  1571. C Not takeable.  If we care, fail.
  1572. C
  1573.       IF((SFLAG.AND.VCBIT).EQ.0) GO TO 4000     ! if no care, return.
  1574.       CALL RSPSUB(445,ODO2)
  1575.       RETURN
  1576. C
  1577. C 1000--        It should not be in the room.
  1578. C 2000--        It cant be taken.
  1579. C
  1580. 2000  IF((SFLAG.AND.VCBIT).EQ.0) GO TO 4000     ! if no care, return
  1581. 1000  IF(SCHLST(0,0,HERE,0,0,OBJ).LE.0) GO TO 4000
  1582.       I=665                                     ! assume player.
  1583.       IF(WINNER.NE.PLAYER) I=1082
  1584.       CALL RSPSUB(I,ODO2)                       ! doesn't have it.
  1585.       RETURN
  1586. C
  1587. C 3000--        Take object.
  1588. C
  1589. 3000  IF(LIT(HERE)) GO TO 3500                  ! lit?
  1590.       CALL RSPEAK(579)                          ! can't do it.
  1591.       RETURN
  1592. C
  1593. 3500  SVA=PRSA                                  ! save parse vector
  1594.       SVO=PRSO
  1595.       SVI=PRSI
  1596.       PRSA=TAKEW                                ! make 'take obj'
  1597.       PRSO=OBJ
  1598.       PRSI=0                                    ! no indirect object
  1599.       TAKEIT=TAKE(.TRUE.)                       ! try to take object
  1600.       PRSA=SVA                                  ! restore parse vector.
  1601.       PRSO=SVO
  1602.       PRSI=SVI
  1603.       RETURN
  1604. C
  1605. C 4000--        Win on general principles.
  1606. C
  1607. 4000  TAKEIT=.TRUE.
  1608.       RETURN
  1609. C
  1610.       END
  1611.  
  1612. C GWIM- Get what I mean in ambiguous situations
  1613. C
  1614. C Declarations
  1615. C
  1616.       INTEGER FUNCTION GWIM(SFLAG,SFW1,SFW2)
  1617.       IMPLICIT INTEGER(A-Z)
  1618.       INCLUDE 'dparam.for'
  1619.       LOGICAL TAKEIT,NOCARE,LIT
  1620. C
  1621.       GWIM=0                                    ! no result.
  1622.       IF(DEADF) RETURN                          ! dead? gwim disabled.
  1623.       AV=AVEHIC(WINNER)
  1624.       NOCARE=(SFLAG.AND.VCBIT).EQ.0
  1625. C
  1626. C First search adventurer
  1627. C
  1628.       IF((SFLAG.AND.VABIT).NE.0)
  1629.      1GWIM=FWIM(SFW1,SFW2,0,0,WINNER,NOCARE)
  1630.       IF((GWIM.LT.0).OR..NOT.LIT(HERE).OR.
  1631.      1 ((SFLAG.AND.VRBIT).EQ.0)) RETURN
  1632. C
  1633. C Also search room
  1634. C
  1635. 100   ROBJ=FWIM(SFW1,SFW2,HERE,0,0,NOCARE)
  1636.       IF(ROBJ) 500,600,200                      ! test result.
  1637. C
  1638. C ROBJ > 0: if prev object, fail
  1639. C
  1640. 200   IF((AV.EQ.0).OR.(ROBJ.EQ.AV).OR.
  1641.      1((OFLAG2(ROBJ).AND.FINDBT).NE.0)) GO TO 300
  1642.       IF(OCAN(ROBJ).NE.AV) RETURN               ! unreachable? use prev obj.
  1643. C
  1644. 300   IF(GWIM.EQ.0) GO TO 400                   ! prev obj?
  1645.       GWIM=-GWIM                                ! yes, ambiguous.
  1646.       RETURN
  1647. C
  1648. 400   IF(.NOT.TAKEIT(ROBJ,SFLAG)) RETURN        ! if untakeable, return prev.
  1649. 500   GWIM=ROBJ                                 ! return room seach.
  1650. 600   RETURN
  1651. C
  1652.       END
  1653.  
  1654. C NOADJS-       See if any adjectives for object
  1655. C
  1656. C Declarations
  1657. C
  1658.       LOGICAL FUNCTION NOADJS(OBJ)
  1659.       IMPLICIT INTEGER(A-Z)
  1660.       INCLUDE 'dparam.for'
  1661. C
  1662.       NOADJS=.FALSE.                            ! assume false.
  1663.       DO 100 I=1,AVMAX                          ! search adj.
  1664.         IF(IABS(AVOC(I)).EQ.OBJ) RETURN         ! found adjective?
  1665.         IF(AVOC(I).EQ.0) GO TO 200              ! end of list?
  1666. 100   CONTINUE
  1667. 200   NOADJS=.TRUE.                             ! true.
  1668.       RETURN
  1669. C
  1670.       END
  1671.  
  1672. C LCIFY-        "Lower case"-ify a string for printing
  1673. C
  1674. C Declarations
  1675. C
  1676.       CHARACTER*(*) FUNCTION LCIFY(STRING,START)
  1677.       IMPLICIT INTEGER(A-Z)
  1678.       CHARACTER*(*) STRING
  1679. C
  1680.       LCIFY=STRING                              ! assume input = output.
  1681.       K=LEN(STRING)                             ! get input length.
  1682.       IF(START.GT.K) RETURN                     ! anything to convert?
  1683. C
  1684.       ULCVT=ICHAR('a')-ICHAR('A')               ! conversion factor
  1685.       DO 100 I=START,K                          ! loop on characters
  1686.         IF((STRING(I:I).GE.'A').AND.(STRING(I:I).LE.'Z'))
  1687.      1LCIFY(I:I)=CHAR(ICHAR(STRING(I:I))+ULCVT)
  1688. 100   CONTINUE
  1689.       RETURN
  1690. C
  1691.       END
  1692.  
  1693. C FINDVB-       Find verb string corresponding to syntax.
  1694. C
  1695. C Declarations
  1696. C
  1697.       CHARACTER*(*) FUNCTION FINDVB(SYNTAX)
  1698.       IMPLICIT INTEGER(A-Z)
  1699.       INCLUDE 'dparam.for'
  1700. C
  1701.       J=1
  1702.       DO 100 K=1,VWMAX                          ! loop through verbs
  1703.         NEWJ=J+VVOC(J)+1                        ! start of next syntax
  1704.         IF((J.LE.SYNTAX).AND.(SYNTAX.LT.NEWJ)) GO TO 200
  1705.         IF(VWORD(K)(1:1).NE.'*') J=NEWJ         ! if last synonym, advance.
  1706. 100   CONTINUE
  1707.       FINDVB=' '                                ! disaster
  1708.       RETURN
  1709. C
  1710. 200   FINDVB=VWORD(K)                           ! return string
  1711.       IF(VWORD(K)(1:1).EQ.'*') FINDVB=VWORD(K)(2:WRDLNT)
  1712.       RETURN
  1713. C
  1714.       END
  1715.  
  1716. C FINDPR-       Find preposition string corresponding to index.
  1717. C
  1718. C Declarations
  1719. C
  1720.       CHARACTER*(*) FUNCTION FINDPR(PREPNO)
  1721.       IMPLICIT INTEGER(A-Z)
  1722.       INCLUDE 'dparam.for'
  1723. C
  1724.       DO 100 I=1,PWMAX                          ! loop through prepositions.
  1725.         IF(PVOC(I).EQ.PREPNO) GO TO 200
  1726. 100   CONTINUE
  1727.       FINDPR=' '
  1728.       RETURN
  1729. C
  1730. 200   FINDPR=PWORD(I)
  1731.       RETURN
  1732. C
  1733.       END
  1734.